home *** CD-ROM | disk | FTP | other *** search
/ PC Open 101 / PC Open 101 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / POPFile / History.pm < prev    next >
Encoding:
Perl POD Document  |  2004-09-22  |  39.3 KB  |  1,312 lines
  1. # POPFILE LOADABLE MODULE
  2. package POPFile::History;
  3.  
  4. use POPFile::Module;
  5. @ISA = ("POPFile::Module");
  6.  
  7. #----------------------------------------------------------------------------
  8. #
  9. # This module handles POPFile's history.  It manages entries in the POPFile
  10. # database and on disk that store messages previously classified by POPFile.
  11. #
  12. # Copyright (c) 2004 John Graham-Cumming
  13. #
  14. #   This file is part of POPFile
  15. #
  16. #   POPFile is free software; you can redistribute it and/or modify
  17. #   it under the terms of the GNU General Public License as published by
  18. #   the Free Software Foundation; either version 2 of the License, or
  19. #   (at your option) any later version.
  20. #
  21. #   POPFile is distributed in the hope that it will be useful,
  22. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  23. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24. #   GNU General Public License for more details.
  25. #
  26. #   You should have received a copy of the GNU General Public License
  27. #   along with POPFile; if not, write to the Free Software
  28. #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  29. #
  30. #----------------------------------------------------------------------------
  31.  
  32. use strict;
  33. use warnings;
  34. use locale;
  35.  
  36. use Date::Parse;
  37. use Digest::MD5 qw( md5_hex );
  38.  
  39. my $fields_slot = 'history.id, hdr_from, hdr_to, hdr_cc, hdr_subject,
  40. hdr_date, hash, inserted, buckets.name, usedtobe, history.bucketid, magnets.val, size';
  41.  
  42. #----------------------------------------------------------------------------
  43. # new
  44. #
  45. #   Class new() function
  46. #----------------------------------------------------------------------------
  47. sub new
  48. {
  49.     my $proto = shift;
  50.     my $class = ref($proto) || $proto;
  51.     my $self = POPFile::Module->new();
  52.  
  53.     # List of committed history items waiting to be committed
  54.     # into the database, it consists of lists containing three
  55.     # elements: the slot id, the bucket classified to and the
  56.     # magnet if used
  57.  
  58.     $self->{commit_list__} = ();
  59.  
  60.     # Contains queries started with start_query and consists
  61.     # of a mapping between unique IDs and quadruples containing
  62.     # a reference to the SELECT and a cache of already fetched
  63.     # rows and a total row count.  These quadruples are implemented
  64.     # as a sub-hash with keys query, count, cache, fields
  65.  
  66.     $self->{queries__} = ();
  67.  
  68.     $self->{firsttime__} = 1;
  69.  
  70.     # Will contain the database handle retrieved from
  71.     # Classifier::Bayes
  72.  
  73.     $self->{db__} = undef;
  74.  
  75.     $self->{classifier__} = 0;
  76.  
  77.     bless($self, $class);
  78.  
  79.     $self->name( 'history' );
  80.  
  81.     return $self;
  82. }
  83.  
  84. #----------------------------------------------------------------------------
  85. #
  86. # initialize
  87. #
  88. # Called to initialize the history module
  89. #
  90. #----------------------------------------------------------------------------
  91. sub initialize
  92. {
  93.     my ( $self ) = @_;
  94.  
  95.     # Keep the history for two days
  96.  
  97.     $self->config_( 'history_days', 2 );
  98.  
  99.     # If 1, Messages are saved to an archive when they are removed or expired
  100.     # from the history cache
  101.  
  102.     $self->config_( 'archive', 0 );
  103.  
  104.     # The directory where messages will be archived to, in sub-directories for
  105.     # each bucket
  106.  
  107.     $self->config_( 'archive_dir', 'archive' );
  108.  
  109.     # This is an advanced setting which will save archived files to a
  110.     # randomly numbered sub-directory, if set to greater than zero, otherwise
  111.     # messages will be saved in the bucket directory
  112.     #
  113.     # 0 <= directory name < archive_classes
  114.  
  115.     $self->config_( 'archive_classes', 0 );
  116.  
  117.     # Need TICKD message for history clean up, COMIT when a message
  118.     # is committed to the history
  119.  
  120.     $self->mq_register_( 'TICKD', $self );
  121.     $self->mq_register_( 'COMIT', $self );
  122.  
  123.     return 1;
  124. }
  125.  
  126. #----------------------------------------------------------------------------
  127. #
  128. # stop
  129. #
  130. # Called to stop the history module
  131. #
  132. #----------------------------------------------------------------------------
  133. sub stop
  134. {
  135.     my ( $self ) = @_;
  136.  
  137.     # Commit any remaining history items.  This is needed because it's
  138.     # possible that we get called with a stop after things have been
  139.     # added to the queue and before service() is called
  140.  
  141.     $self->commit_history__();
  142. }
  143.  
  144. #----------------------------------------------------------------------------
  145. #
  146. # db__
  147. #
  148. # Since we don't know the order in which the start() methods of PLMs
  149. # is called we cannot be sure that Classifier::Bayes will have started
  150. # and connected to the database before us, hence we can't set our
  151. # database handle at start time.  So instead we access the db handle
  152. # through this method
  153. #
  154. #----------------------------------------------------------------------------
  155. sub db__
  156. {
  157.     my ( $self ) = @_;
  158.  
  159.     if ( !defined( $self->{db__} ) ) {
  160.         $self->{db__} = $self->{classifier__}->db()->clone;
  161.     }
  162.  
  163.     return $self->{db__};
  164. }
  165.  
  166. #----------------------------------------------------------------------------
  167. #
  168. # service
  169. #
  170. # Called periodically so that the module can do its work
  171. #
  172. #----------------------------------------------------------------------------
  173. sub service
  174. {
  175.     my ( $self ) = @_;
  176.  
  177.     if ( $self->{firsttime__} ) {
  178.         $self->upgrade_history_files__();
  179.         $self->{firsttime__} = 0;
  180.     }
  181.  
  182.     # Note when we go to multiuser POPFile we'll need to change this call
  183.     # so that we are sure that the session IDs that it is using are still
  184.     # valid.  The easiest way will be to call it in deliver() when we get
  185.     # a COMIT message.
  186.  
  187.     $self->commit_history__();
  188.  
  189.     return 1;
  190. }
  191.  
  192. #----------------------------------------------------------------------------
  193. #
  194. # deliver
  195. #
  196. # Called by the message queue to deliver a message
  197. #
  198. # There is no return value from this method
  199. #
  200. #----------------------------------------------------------------------------
  201. sub deliver
  202. {
  203.     my ( $self, $type, @message ) = @_;
  204.  
  205.     # If a day has passed then clean up the history
  206.  
  207.     if ( $type eq 'TICKD' ) {
  208.         $self->cleanup_history();
  209.     }
  210.  
  211.     if ( $type eq 'COMIT' ) {
  212.         push ( @{$self->{commit_list__}}, \@message );
  213.     }
  214. }
  215.  
  216. # ---------------------------------------------------------------------------
  217. #
  218. # forked
  219. #
  220. # This is called inside a child process that has just forked, since the
  221. # child needs access to the database we open it
  222. #
  223. # ---------------------------------------------------------------------------
  224. sub forked
  225. {
  226.     my ( $self ) = @_;
  227.  
  228.     $self->{db__} = undef;
  229. }
  230.  
  231. #----------------------------------------------------------------------------
  232. #
  233. # ADDING TO THE HISTORY
  234. #
  235. # To add a message to the history the following sequence of calls
  236. # is made:
  237. #
  238. # 1. Obtain a unique ID and filename for the new message by a call
  239. #    to reserve_slot
  240. #
  241. # 2. Write the message into the filename returned
  242. #
  243. # 3. Call commit_slot with the bucket into which the message was
  244. #    classified
  245. #
  246. # If an error occurs after #1 and the slot is unneeded then call
  247. # release_slot
  248. #
  249. #----------------------------------------------------------------------------
  250. #
  251. # FINDING A HISTORY ENTRY
  252. #
  253. # 1. If you know the slot id then call get_slot_file to obtain
  254. #    the full path where the file is stored
  255. #
  256. # 2. If you know the message hash then call get_slot_from hash
  257. #    to get the slot id
  258. #
  259. # 3. If you know the message headers then use get_message_hash
  260. #    to get the hash
  261. #
  262. #----------------------------------------------------------------------------
  263.  
  264. #----------------------------------------------------------------------------
  265. #
  266. # reserve_slot
  267. #
  268. # Called to reserve a place in the history for a message that is in the
  269. # process of being received.  It returns a unique ID for this slot and
  270. # the full path to the file where the message should be stored.  The
  271. # caller is expected to later call either release_slot (if the slot is not
  272. # going to be used) or commit_slot (if the file has been written and the
  273. # entry should be added to the history).
  274. #
  275. #----------------------------------------------------------------------------
  276. sub reserve_slot
  277. {
  278.     my ( $self ) = @_;
  279.  
  280.     my $r;
  281.  
  282.     while (1) {
  283.         $r = int(rand( 1000000000 )+2);
  284.  
  285.         $self->log_( 2, "reserve_slot selected random number $r" );
  286.  
  287.         # TODO Replace the hardcoded user ID 1 with the looked up
  288.         # user ID from the session key
  289.  
  290.         my $test = $self->db__()->selectrow_arrayref(
  291.                  "select id from history where committed = $r limit 1;");
  292.  
  293.         if ( defined( $test ) ) {
  294.             next;
  295.         }
  296.  
  297.         # Get the date/time now which will be stored in the database
  298.         # so that we can sort on the Date: header in the message and
  299.         # when we received it
  300.  
  301.         my $now = time;
  302.         $self->db__()->do(
  303.             "insert into history ( userid, committed, inserted ) values ( 1, $r, $now );" );
  304.         last;
  305.     }
  306.  
  307.     my $result = $self->db__()->selectrow_arrayref(
  308.                  "select id from history where committed = $r limit 1;");
  309.  
  310.     my $slot = $result->[0];
  311.  
  312.     $self->log_( 2, "reserve_slot returning slot id $slot" );
  313.  
  314.     return ( $slot, $self->get_slot_file( $slot ) );
  315. }
  316.  
  317. #----------------------------------------------------------------------------
  318. #
  319. # release_slot
  320. #
  321. # See description with reserve_slot; release_slot releases a history slot
  322. # previously allocated with reserve_slot and discards it.
  323. #
  324. # id              Unique ID returned by reserve_slot
  325. #
  326. #----------------------------------------------------------------------------
  327. sub release_slot
  328. {
  329.     my ( $self, $slot ) = @_;
  330.  
  331.     # Remove the entry from the database and delete the file
  332.     # if present
  333.  
  334.     my $delete = "delete from history where history.id = $slot;";
  335.  
  336.     $self->db__()->do( $delete );
  337.  
  338.     my $file = $self->get_slot_file( $slot );
  339.  
  340.     unlink $file;
  341.  
  342.     # It's not possible that the directory for the slot file is empty
  343.     # and we want to delete it so that things get cleaned up automatically
  344.  
  345.     $file =~ s/popfile[a-f0-9]{2}\.msg$//i;
  346.  
  347.     my $depth = 3;
  348.  
  349.     while ( $depth > 0 ) {
  350.         my @files = glob( $file . '*' );
  351.  
  352.         if ( $#files == -1 ) {
  353.             if ( !( rmdir( $file ) ) ) {
  354.                 last;
  355.             }
  356.             $file =~ s![a-f0-9]{2}/$!!i;
  357.         } else {
  358.             last;
  359.         }
  360.  
  361.         $depth--;
  362.     }
  363. }
  364.  
  365. #----------------------------------------------------------------------------
  366. #
  367. # commit_slot
  368. #
  369. # See description with reserve_slot; commit_slot commits a history
  370. # slot to the database and makes it part of the history.  Before this
  371. # is called the full message should have been written to the file
  372. # returned by reserve_slot.  Note that commit_slot queues the message
  373. # for insertion and does not commit it until some (short) time later
  374. #
  375. # session         User session with Classifier::Bayes API
  376. # slot            Unique ID returned by reserve_slot
  377. # bucket          Bucket classified to
  378. # magnet          Magnet if used
  379. #
  380. #----------------------------------------------------------------------------
  381. sub commit_slot
  382. {
  383.     my ( $self, $session, $slot, $bucket, $magnet ) = @_;
  384.  
  385.     $self->mq_post_( 'COMIT', $session, $slot, $bucket, $magnet );
  386. }
  387.  
  388. #----------------------------------------------------------------------------
  389. #
  390. # change_slot_classification
  391. #
  392. # Used to 'reclassify' a message by changing its classification in the
  393. # database.
  394. #
  395. # slot         The slot to update
  396. # class        The new classification
  397. # session      A valid API session
  398. # undo         If set to 1 then indicates an undo operation
  399. #
  400. #----------------------------------------------------------------------------
  401. sub change_slot_classification
  402. {
  403.     my ( $self, $slot, $class, $session, $undo ) = @_;
  404.  
  405.     $self->log_( 0, "Change slot classification of $slot to $class" );
  406.  
  407.     # Get the bucket ID associated with the new classification
  408.     # then retrieve the current classification for this slot
  409.     # and update the database
  410.  
  411.     my $bucketid = $self->{classifier__}->get_bucket_id(
  412.                            $session, $class );
  413.  
  414.     my $oldbucketid = 0;
  415.     if ( !$undo ) {
  416.         my @fields = $self->get_slot_fields( $slot );
  417.         $oldbucketid = $fields[10];
  418.     }
  419.  
  420.     $self->db__()->do( "update history set bucketid = $bucketid,
  421.                                            usedtobe = $oldbucketid
  422.                                        where id = $slot;" );
  423.     $self->force_requery__();
  424. }
  425.  
  426. #----------------------------------------------------------------------------
  427. #
  428. # revert_slot_classification
  429. #
  430. # Used to undo a 'reclassify' a message by changing its classification
  431. # in the database.
  432. #
  433. # slot         The slot to update
  434. #
  435. #----------------------------------------------------------------------------
  436. sub revert_slot_classification
  437. {
  438.     my ( $self, $slot ) = @_;
  439.  
  440.     my @fields = $self->get_slot_fields( $slot );
  441.     my $oldbucketid = $fields[9];
  442.  
  443.     $self->db__()->do( "update history set bucketid = $oldbucketid,
  444.                                            usedtobe = 0
  445.                                        where id = $slot;" );
  446.     $self->force_requery__();
  447. }
  448.  
  449. #---------------------------------------------------------------------------
  450. #
  451. # get_slot_fields
  452. #
  453. # Returns the fields associated with a specific slot.  We return the
  454. # same collection of fields as get_query_rows.
  455. #
  456. # slot           The slot id
  457. #
  458. #---------------------------------------------------------------------------
  459. sub get_slot_fields
  460. {
  461.     my ( $self, $slot ) = @_;
  462.  
  463.     return $self->db__()->selectrow_array(
  464.         "select $fields_slot from history, buckets, magnets
  465.              where history.id = $slot and
  466.                    buckets.id = history.bucketid and
  467.                    magnets.id = magnetid;" );
  468. }
  469.  
  470. #---------------------------------------------------------------------------
  471. #
  472. # is_valid_slot
  473. #
  474. # Returns 1 if the slot ID passed in is valid
  475. #
  476. # slot           The slot id
  477. #
  478. #---------------------------------------------------------------------------
  479. sub is_valid_slot
  480. {
  481.     my ( $self, $slot ) = @_;
  482.  
  483.     my @row = $self->db__()->selectrow_array(
  484.         "select id from history where history.id = $slot;" );
  485.  
  486.     return ( ( @row ) && ( $row[0] == $slot ) );
  487. }
  488.  
  489. #---------------------------------------------------------------------------
  490. #
  491. # commit_history__
  492. #
  493. # (private) Used internally to commit messages that have been committed
  494. # with a call to commit_slot to the database
  495. #
  496. #----------------------------------------------------------------------------
  497. sub commit_history__
  498. {
  499.     my ( $self ) = @_;
  500.  
  501.     if ( $#{$self->{commit_list__}} == -1 ) {
  502.         return;
  503.     }
  504.  
  505.     foreach my $entry (@{$self->{commit_list__}}) {
  506.         my ( $session, $slot, $bucket, $magnet ) = @{$entry};
  507.  
  508.         my $file = $self->get_slot_file( $slot );
  509.  
  510.         # Committing to the history requires the following steps
  511.         #
  512.         # 1. Parse the message to extract the headers
  513.         # 2. Compute MD5 hash of Message-ID, Date and Subject
  514.         # 3. Update the related row with the headers and
  515.         #    committed set to 1
  516.  
  517.         my %header;
  518.  
  519.         if ( open FILE, "<$file" ) {
  520.             my $last;
  521.             while ( <FILE> ) {
  522.                 s/[\r\n]//g;
  523.  
  524.                 if ( /^$/ ) {
  525.                     last;
  526.                 }
  527.  
  528.                 if ( /^([^ \t]+):[ \t]*(.*)$/ ) {
  529.                     $last = lc $1;
  530.                     push @{$header{$last}}, $2;
  531.  
  532.                 } else {
  533.                     if ( defined $last ) {
  534.                         ${$header{$last}}[$#{$header{$last}}] .= $_;
  535.                     }
  536.                 }
  537.             }
  538.             close FILE;
  539.         }
  540.         else {
  541.             $self->log_( 0, "Could not open history message file $file for reading." );
  542.         }
  543.  
  544.         my $hash = $self->get_message_hash( ${$header{'message-id'}}[0],
  545.                                             ${$header{'date'}}[0],
  546.                                             ${$header{'subject'}}[0],
  547.                                             ${$header{'received'}}[0] );
  548.         $hash = $self->db__()->quote( $hash );
  549.  
  550.         # For sorting purposes the From, To and CC headers have special
  551.         # cleaned up versions of themselves in the database.  The idea
  552.         # is that case and certain characters should be ignored when
  553.         # sorting these fields
  554.         #
  555.         # "John Graham-Cumming" <spam@jgc.org> maps to
  556.         #     john graham-cumming <spam@jgc.org>
  557.  
  558.         my @sortable = ( 'from', 'to', 'cc' );
  559.         my %sort_headers;
  560.  
  561.         foreach my $h (@sortable) {
  562.             $sort_headers{$h} =
  563.                  $self->{classifier__}->{parser__}->decode_string(
  564.                      ${$header{$h}}[0] );
  565.             $sort_headers{$h} = lc($sort_headers{$h} || '');
  566.             $sort_headers{$h} =~ s/[\"<>]//g;
  567.             $sort_headers{$h} =~ s/^[ \t]+//g;
  568.             $sort_headers{$h} =~ s/\0//g;
  569.             $sort_headers{$h} = $self->db__()->quote(
  570.                 $sort_headers{$h} );
  571.         }
  572.  
  573.         # Make sure that the headers we are going to insert into
  574.         # the database have been defined and are suitably quoted
  575.  
  576.         my @required = ( 'from', 'to', 'cc', 'subject' );
  577.  
  578.         foreach my $h (@required) {
  579.             if ( !defined ${$header{$h}}[0] || ${$header{$h}}[0] =~ /^\s*$/ ) {
  580.                 if ( $h ne 'cc' ) {
  581.                     ${$header{$h}}[0] = "<$h header missing>";
  582.                 } else {
  583.                     ${$header{$h}}[0] = '';
  584.                 }
  585.             }
  586.  
  587.             ${$header{$h}}[0] =
  588.                  $self->{classifier__}->{parser__}->decode_string(
  589.                      ${$header{$h}}[0] );
  590.             ${$header{$h}}[0] =~ s/\0//g;
  591.             ${$header{$h}}[0] = $self->db__()->quote( ${$header{$h}}[0] );
  592.         }
  593.  
  594.         # If we do not have a date header then set the date to
  595.         # 0 (start of the Unix epoch), otherwise parse the string
  596.         # using Date::Parse to interpret it and turn it into the
  597.         # Unix epoch.
  598.  
  599.         if ( !defined( ${$header{date}}[0] ) ) {
  600.             ${$header{date}}[0] = 0;
  601.         } else {
  602.             ${$header{date}}[0] = str2time( ${$header{date}}[0] ) || 0;
  603.         }
  604.  
  605.         # Figure out the ID of the bucket this message has been
  606.         # classified into (and the same for the magnet if it is
  607.         # defined)
  608.  
  609.         my $bucketid = $self->{classifier__}->get_bucket_id(
  610.                            $session, $bucket );
  611.  
  612.         my $msg_size = -s $file;
  613.  
  614.         # If we can't get the bucket ID because the bucket doesn't exist
  615.         # which could happen when we are upgrading the history which
  616.         # has old bucket names in it then we will remove the entry from the
  617.         # history and log the failure
  618.  
  619.         if ( defined( $bucketid ) ) {
  620.             my $result = $self->db__()->do(
  621.                 "update history set hdr_from    = ${$header{from}}[0],
  622.                                     hdr_to      = ${$header{to}}[0],
  623.                                     hdr_date    = ${$header{date}}[0],
  624.                                     hdr_cc      = ${$header{cc}}[0],
  625.                                     hdr_subject = ${$header{subject}}[0],
  626.                                     sort_from   = $sort_headers{from},
  627.                                     sort_to     = $sort_headers{to},
  628.                                     sort_cc     = $sort_headers{cc},
  629.                                     committed   = 1,
  630.                                     bucketid    = $bucketid,
  631.                                     usedtobe    = 0,
  632.                                     magnetid    = $magnet,
  633.                                     hash        = $hash,
  634.                                     size        = $msg_size
  635.                                     where id = $slot;" );
  636.         } else {
  637.             $self->log_( 0, "Couldn't find bucket ID for bucket $bucket when committing $slot" );
  638.             $self->release_slot( $slot );
  639.         }
  640.     }
  641.  
  642.     $self->{commit_list__} = ();
  643.     $self->force_requery__();
  644. }
  645.  
  646. # ---------------------------------------------------------------------------
  647. #
  648. # delete_slot
  649. #
  650. # Deletes an entry from the database and disk, optionally archiving it
  651. # if the archive parameters have been set
  652. #
  653. # $slot              The slot ID
  654. # $archive           1 if it's OK to archive this entry
  655. #
  656. # ---------------------------------------------------------------------------
  657. sub delete_slot
  658. {
  659.     my ( $self, $slot, $archive ) = @_;
  660.  
  661.     my $file = $self->get_slot_file( $slot );
  662.     $self->log_( 2, "delete_slot called for slot $slot, file $file" );
  663.  
  664.     if ( $archive && $self->config_( 'archive' ) ) {
  665.         my $path = $self->get_user_path_( $self->config_( 'archive_dir' ), 0 );
  666.  
  667.         $self->make_directory__( $path );
  668.  
  669.         my @b = $self->db__()->selectrow_array(
  670.             "select buckets.name from history, buckets
  671.                  where history.bucketid = buckets.id and
  672.                        history.id = $slot;" );
  673.  
  674.         my $bucket = $b[0];
  675.  
  676.         if ( ( $bucket ne 'unclassified' ) &&
  677.              ( $bucket ne 'unknown class' ) ) {
  678.             $path .= "\/" . $bucket;
  679.             $self->make_directory__( $path );
  680.  
  681.             if ( $self->config_( 'archive_classes' ) > 0) {
  682.  
  683.                 # Archive to a random sub-directory of the bucket archive
  684.  
  685.                 my $subdirectory = int( rand(
  686.                     $self->config_( 'archive_classes' ) ) );
  687.                 $path .= "\/" . $subdirectory;
  688.                 $self->make_directory__( $path );
  689.             }
  690.  
  691.             # Previous comment about this potentially being unsafe
  692.             # (may have placed messages in unusual places, or
  693.             # overwritten files) no longer applies. Files are now
  694.             # placed in the user directory, in the archive_dir
  695.             # subdirectory
  696.  
  697.             $self->copy_file__( $file, $path, "popfile$slot.msg" );
  698.         }
  699.     }
  700.  
  701.     # Now remove the entry from the database, and the file from disk,
  702.     # and also invalidate the caches of any open queries since they
  703.     # may have been affected
  704.  
  705.     $self->release_slot( $slot );
  706.     $self->force_requery__();
  707. }
  708.  
  709. #----------------------------------------------------------------------------
  710. #
  711. # get_slot_file
  712. #
  713. # Used to map a slot ID to the full path of the file will contain
  714. # the message associated with the slot
  715. #
  716. #----------------------------------------------------------------------------
  717. sub get_slot_file
  718. {
  719.     my ( $self, $slot ) = @_;
  720.  
  721.     # The mapping between the slot and the file goes as follows:
  722.     #
  723.     # 1. Convert the file to an 8 digit hex number (with leading
  724.     #    zeroes).
  725.     # 2. Call that number aabbccdd
  726.     # 3. Build the path aa/bb/cc
  727.     # 4. Name the file popfiledd.msg
  728.     # 5. Add the msgdir location to obtain
  729.     #        msgdir/aa/bb/cc/popfiledd.msg
  730.     #
  731.     # Hence each directory can have up to 256 entries
  732.  
  733.     my $hex_slot = sprintf( '%8.8x', $slot );
  734.     my $path = $self->get_user_path_(
  735.                    $self->global_config_( 'msgdir' ) .
  736.                        substr( $hex_slot, 0, 2 ) . '/', 0 );
  737.  
  738.     $self->make_directory__( $path );
  739.     $path .= substr( $hex_slot, 2, 2 ) . '/';
  740.     $self->make_directory__( $path );
  741.     $path .= substr( $hex_slot, 4, 2 ) . '/';
  742.     $self->make_directory__( $path );
  743.  
  744.     my $file = 'popfile' .
  745.                substr( $hex_slot, 6, 2 ) . '.msg';
  746.  
  747.     return $path . $file;
  748. }
  749.  
  750. #----------------------------------------------------------------------------
  751. #
  752. # get_message_hash
  753. #
  754. # Used to compute an MD5 hash of the headers of a message
  755. # so that the same message can later me identified by a
  756. # call to get_slot_from_hash
  757. #
  758. # messageid              The message id header
  759. # date                   The date header
  760. # subject                The subject header
  761. # received               First Received header line
  762. #
  763. # Note that the values passed in are everything after the : in
  764. # header without the trailing \r or \n.  If a header is missing
  765. # then pass in the empty string
  766. #
  767. #----------------------------------------------------------------------------
  768. sub get_message_hash
  769. {
  770.     my ( $self, $messageid, $date, $subject, $received ) = @_;
  771.  
  772.     $messageid = '' if ( !defined( $messageid ) );
  773.     $date      = '' if ( !defined( $date      ) );
  774.     $subject   = '' if ( !defined( $subject   ) );
  775.     $received  = '' if ( !defined( $received  ) );
  776.  
  777.     return md5_hex( "[$messageid][$date][$subject][$received]" );
  778. }
  779.  
  780. #----------------------------------------------------------------------------
  781. #
  782. # get_slot_from_hash
  783. #
  784. # Given a hash value (returned by get_message_hash), find any
  785. # corresponding message in the database and return its slot
  786. # id.   If the message does not exist then return the empty
  787. # string.
  788. #
  789. # hash                 The hash value
  790. #
  791. #----------------------------------------------------------------------------
  792. sub get_slot_from_hash
  793. {
  794.     my ( $self, $hash ) = @_;
  795.  
  796.     $hash = $self->db__()->quote( $hash );
  797.     my $result = $self->db__()->selectrow_arrayref(
  798.         "select id from history where hash = $hash limit 1;" );
  799.  
  800.     return defined( $result )?$result->[0]:'';
  801. }
  802.  
  803. #----------------------------------------------------------------------------
  804. #
  805. # QUERYING THE HISTORY
  806. #
  807. # 1. Start a query session by calling start_query and obtain a unique
  808. #    ID
  809. #
  810. # 2. Set the query parameter (i.e. sort, search and filter) with a call
  811. #    to set_query
  812. #
  813. # 3. Obtain the number of history rows returned by calling get_query_size
  814. #
  815. # 4. Get segments of the history returned by calling get_query_rows with
  816. #    the start and end rows needed
  817. #
  818. # 5. When finished with the query call stop_query
  819. #
  820. #----------------------------------------------------------------------------
  821.  
  822. #----------------------------------------------------------------------------
  823. #
  824. # start_query
  825. #
  826. # Used to start a query session, returns a unique ID for this
  827. # query.  When the caller is done with the query they return
  828. # stop_query.
  829. #
  830. #----------------------------------------------------------------------------
  831. sub start_query
  832. {
  833.     my ( $self ) = @_;
  834.  
  835.     # Think of a large random number, make sure that it hasn't
  836.     # been used and then return it
  837.  
  838.     while (1) {
  839.         my $id = sprintf( '%8.8x', int(rand(4294967295)) );
  840.  
  841.         if ( !defined( $self->{queries__}{$id} ) ) {
  842.             $self->{queries__}{$id}{query} = 0;
  843.             $self->{queries__}{$id}{count} = 0;
  844.             $self->{queries__}{$id}{cache} = ();
  845.             return $id
  846.         }
  847.     }
  848. }
  849.  
  850. #----------------------------------------------------------------------------
  851. #
  852. # stop_query
  853. #
  854. # Used to clean up after a query session
  855. #
  856. # id                The ID returned by start_query
  857. #
  858. #----------------------------------------------------------------------------
  859. sub stop_query
  860. {
  861.     my ( $self, $id ) = @_;
  862.  
  863.     # If the cache size hasn't grown to the row
  864.     # count then we didn't fetch everything and so
  865.     # we fill call finish to clean up
  866.  
  867.     my $q = $self->{queries__}{$id}{query};
  868.  
  869.     if ( ( defined $q ) && ( $q != 0 ) ) {
  870.         if ( $#{$self->{queries__}{$id}{cache}} !=
  871.              $self->{queries__}{$id}{count} ) {
  872.            $q->finish;
  873.         }
  874.     }
  875.  
  876.     delete $self->{queries__}{$id};
  877. }
  878.  
  879. #----------------------------------------------------------------------------
  880. #
  881. # set_query
  882. #
  883. # Called to set up a query with sort, filter and search options
  884. #
  885. # id            The ID returned by start_query
  886. # filter        Name of bucket to filter on
  887. # search        From/Subject line to search for
  888. # sort          The field to sort on (from, subject, to, cc, bucket, date)
  889. #               (optional leading - for descending sort)
  890. # not           If set to 1 negates the search
  891. #
  892. #----------------------------------------------------------------------------
  893. sub set_query
  894. {
  895.     my ( $self, $id, $filter, $search, $sort, $not ) = @_;
  896.  
  897.     # If this query has already been done and is in the cache
  898.     # then do no work here
  899.  
  900.     if ( defined( $self->{queries__}{$id}{fields} ) &&
  901.          ( $self->{queries__}{$id}{fields} eq
  902.              "$filter:$search:$sort:$not" ) ) {
  903.         return;
  904.     }
  905.  
  906.     $self->{queries__}{$id}{fields} = "$filter:$search:$sort:$not";
  907.  
  908.     # We do two queries, the first to get the total number of rows that
  909.     # would be returned and then we start the real query.  This is done
  910.     # so that we know the size of the resulting data without having
  911.     # to retrieve it all
  912.  
  913.     $self->{queries__}{$id}{base} = 'select XXX from
  914.         history, buckets, magnets where history.userid = 1 and committed = 1';
  915.  
  916.     $self->{queries__}{$id}{base} .= ' and history.bucketid = buckets.id';
  917.     $self->{queries__}{$id}{base} .= ' and magnets.id = magnetid';
  918.  
  919.     # If there's a search portion then add the appropriate clause
  920.     # to find the from/subject header
  921.  
  922.     my $not_word  = $not?'not':'';
  923.     my $not_equal = $not?'!=':'=';
  924.     my $equal     = $not?'=':'!=';
  925.  
  926.     if ( $search ne '' ) {
  927.         $search = $self->db__()->quote( '%' . $search . '%' );
  928.         $self->{queries__}{$id}{base} .= " and $not_word ( hdr_from like $search or hdr_subject like $search )";
  929.     }
  930.  
  931.     # If there's a filter option then we'll need to get the bucket
  932.     # id for the filtered bucket and add the appropriate clause
  933.  
  934.     if ( $filter ne '' ) {
  935.         if ( $filter eq '__filter__magnet' ) {
  936.             $self->{queries__}{$id}{base} .=
  937.                 " and history.magnetid $equal 0";
  938.         } else {
  939.             my $session = $self->{classifier__}->get_session_key(
  940.                               'admin', '' );
  941.             my $bucketid = $self->{classifier__}->get_bucket_id(
  942.                                $session, $filter );
  943.             $self->{classifier__}->release_session_key( $session );
  944.             $self->{queries__}{$id}{base} .=
  945.                 " and history.bucketid $not_equal $bucketid";
  946.         }
  947.     }
  948.  
  949.     # Add the sort option (if there is one)
  950.  
  951.     if ( $sort ne '' ) {
  952.         $sort =~ s/^(\-)//;
  953.         my $direction = defined($1)?'desc':'asc';
  954.         if ( $sort eq 'bucket' ) {
  955.             $sort = 'buckets.name';
  956.         } else {
  957.             if ( $sort =~ /from|to|cc/ ) {
  958.                 $sort = "sort_$sort";
  959.             } else {
  960.                 if ( $sort ne 'inserted' && $sort ne 'size' ) {
  961.                     $sort = "hdr_$sort";
  962.                 }
  963.             }
  964.         }
  965.         $self->{queries__}{$id}{base} .= " order by $sort $direction;";
  966.     } else {
  967.         $self->{queries__}{$id}{base} .= ' order by inserted desc;';
  968.     }
  969.  
  970.     my $count = $self->{queries__}{$id}{base};
  971.     $self->log_( 2, "Base query is $count" );
  972.     $count =~ s/XXX/COUNT(*)/;
  973.  
  974.     $self->{queries__}{$id}{count} =
  975.         $self->db__()->selectrow_arrayref( $count )->[0];
  976.  
  977.     my $select = $self->{queries__}{$id}{base};
  978.     $select =~ s/XXX/$fields_slot/;
  979.     $self->{queries__}{$id}{query} = $self->db__()->prepare( $select );
  980.     $self->{queries__}{$id}{query}->execute;
  981.     $self->{queries__}{$id}{cache} = ();
  982. }
  983.  
  984. #----------------------------------------------------------------------------
  985. #
  986. # delete_query
  987. #
  988. # Called to delete all the rows returned in a query
  989. #
  990. # id            The ID returned by start_query
  991. #
  992. #----------------------------------------------------------------------------
  993. sub delete_query
  994. {
  995.     my ( $self, $id ) = @_;
  996.  
  997.     my $delete = $self->{queries__}{$id}{base};
  998.     $delete =~ s/XXX/history.id/;
  999.     my $d = $self->db__()->prepare( $delete );
  1000.     $d->execute;
  1001.     my @row;
  1002.     my @ids;
  1003.     while ( @row = $d->fetchrow_array ) {
  1004.         push ( @ids, $row[0] );
  1005.     }
  1006.     foreach my $id (@ids) {
  1007.         $self->delete_slot( $id, 1 );
  1008.     }
  1009. }
  1010.  
  1011. #----------------------------------------------------------------------------
  1012. #
  1013. # get_query_size
  1014. #
  1015. # Called to return the number of elements in the query.
  1016. # Should only be called after a call to set_query.
  1017. #
  1018. # id            The ID returned by start_query
  1019. #
  1020. #----------------------------------------------------------------------------
  1021. sub get_query_size
  1022. {
  1023.     my ( $self, $id ) = @_;
  1024.  
  1025.     return $self->{queries__}{$id}{count};
  1026. }
  1027.  
  1028. #----------------------------------------------------------------------------
  1029. #
  1030. # get_query_rows
  1031. #
  1032. # Returns the rows in the range [$start, $end) from a query that has
  1033. # already been set up with a call to set_query.  The first row is row 1.
  1034. #
  1035. # id            The ID returned by start_query
  1036. # start         The first row to return
  1037. # count         Number of rows to return
  1038. #
  1039. # Each row contains the fields:
  1040. #
  1041. #    id (0), from (1), to (2), cc (3), subject (4), date (5), hash (6),
  1042. #    inserted date (7), bucket name (8), reclassified id (9), bucket id (10),
  1043. #    magnet value (11), size (12)
  1044. #----------------------------------------------------------------------------
  1045. sub get_query_rows
  1046. {
  1047.     my ( $self, $id, $start, $count ) = @_;
  1048.  
  1049.     # First see if we have already retrieved these rows from the query
  1050.     # if we have then we can just return them from the cache.  Otherwise
  1051.     # fetch the rows from the database and then return them
  1052.  
  1053.     my $size = $#{$self->{queries__}{$id}{cache}}+1;
  1054.  
  1055.     $self->log_( 2, "Request for rows $start ($count), current size $size" );
  1056.  
  1057.     if ( ( $size < ( $start + $count - 1 ) ) ) {
  1058.         my $rows = $start + $count - $size;
  1059.         $self->log_( 2, "Getting $rows rows from database" );
  1060.         push ( @{$self->{queries__}{$id}{cache}},
  1061.             @{$self->{queries__}{$id}{query}->fetchall_arrayref(
  1062.                 undef, $start + $count - $size )} );
  1063.     }
  1064.  
  1065.     my ( $from, $to ) = ( $start-1, $start+$count-2 );
  1066.  
  1067.     $self->log_( 2, "Returning $from..$to" );
  1068.  
  1069.     return @{$self->{queries__}{$id}{cache}}[$from..$to];
  1070. }
  1071.  
  1072. # ---------------------------------------------------------------------------
  1073. #
  1074. # make_directory__
  1075. #
  1076. # Wrapper for mkdir that ensures that the path we are making doesn't end in
  1077. # / or \ (Done because your can't do mkdir 'foo/' on NextStep.
  1078. #
  1079. # $path        The directory to make
  1080. #
  1081. # Returns whatever mkdir returns
  1082. #
  1083. # ---------------------------------------------------------------------------
  1084. sub make_directory__
  1085. {
  1086.     my ( $self, $path ) = @_;
  1087.  
  1088.     $path =~ s/[\\\/]$//;
  1089.  
  1090.     return 1 if ( -d $path );
  1091.     return mkdir( $path );
  1092. }
  1093.  
  1094. # ---------------------------------------------------------------------------
  1095. #
  1096. # compare_mf__
  1097. #
  1098. # Compares two mailfiles, used for sorting mail into order
  1099. #
  1100. # ---------------------------------------------------------------------------
  1101. sub compare_mf__
  1102. {
  1103.     $a =~ /popfile(\d+)=(\d+)\.msg/;
  1104.     my ( $ad, $am ) = ( $1, $2 );
  1105.  
  1106.     $b =~ /popfile(\d+)=(\d+)\.msg/;
  1107.     my ( $bd, $bm ) = ( $1, $2 );
  1108.  
  1109.     if ( $ad == $bd ) {
  1110.         return ( $bm <=> $am );
  1111.     } else {
  1112.         return ( $bd <=> $ad );
  1113.     }
  1114. }
  1115.  
  1116. # ---------------------------------------------------------------------------
  1117. #
  1118. # upgrade_history_files__
  1119. #
  1120. # Looks for old .MSG/.CLS history entries and sticks them in the database
  1121. #
  1122. # ---------------------------------------------------------------------------
  1123. sub upgrade_history_files__
  1124. {
  1125.     my ( $self ) = @_;
  1126.  
  1127.     # See if there are any .MSG files in the msgdir, and if there are
  1128.     # upgrade them by placing them in the database
  1129.  
  1130.     my @msgs = sort compare_mf__ glob $self->get_user_path_(
  1131.         $self->global_config_( 'msgdir' ) . 'popfile*.msg', 0 );
  1132.  
  1133.     if ( $#msgs != -1 ) {
  1134.         my $session = $self->{classifier__}->get_session_key( 'admin', '' );
  1135.  
  1136.         print "\nFound old history files, moving them into database\n    ";
  1137.  
  1138.         my $i = 0;
  1139.         $self->db__()->begin_work;
  1140.         foreach my $msg (@msgs) {
  1141.             if ( ( ++$i % 100 ) == 0 ) {
  1142.                 print "[$i]";
  1143.                 flush STDOUT;
  1144.             }
  1145.  
  1146.             # NOTE.  We drop the information in $usedtobe, so that
  1147.             # reclassified messages will no longer appear reclassified
  1148.             # in upgraded history.  Also the $magnet is ignored so
  1149.             # upgraded history will have no magnet information.
  1150.  
  1151.             my ( $reclassified, $bucket, $usedtobe, $magnet ) =
  1152.                 $self->history_read_class__( $msg );
  1153.  
  1154.             if ( $bucket ne 'unknown_class' ) {
  1155.                 my ( $slot, $file ) = $self->reserve_slot();
  1156.                 rename $msg, $file;
  1157.                 my @message = ( $session, $slot, $bucket, 0 );
  1158.                 push ( @{$self->{commit_list__}}, \@message );
  1159.             }
  1160.         }
  1161.         $self->db__()->commit;
  1162.  
  1163.         print "\nDone upgrading history\n";
  1164.  
  1165.         $self->commit_history__();
  1166.         $self->{classifier__}->release_session_key( $session );
  1167.  
  1168.         unlink $self->get_user_path_(
  1169.             $self->global_config_( 'msgdir' ) . 'history_cache', 0 );
  1170.     }
  1171. }
  1172.  
  1173. # ---------------------------------------------------------------------------
  1174. #
  1175. # history_read_class__ - load and delete the class file for a message.
  1176. #
  1177. # returns: ( reclassified, bucket, usedtobe, magnet )
  1178. #   values:
  1179. #       reclassified:   boolean, true if message has been reclassified
  1180. #       bucket:         string, the bucket the message is in presently,
  1181. #                       unknown class if an error occurs
  1182. #       usedtobe:       string, the bucket the message used to be in
  1183. #                       (null if not reclassified)
  1184. #       magnet:         string, the magnet
  1185. #
  1186. # $filename     The name of the message to load the class for
  1187. #
  1188. # ---------------------------------------------------------------------------
  1189. sub history_read_class__
  1190. {
  1191.     my ( $self, $filename ) = @_;
  1192.  
  1193.     $filename =~ s/msg$/cls/;
  1194.  
  1195.     my $reclassified = 0;
  1196.     my $bucket = 'unknown class';
  1197.     my $usedtobe;
  1198.     my $magnet = '';
  1199.  
  1200.     if ( open CLASS, "<$filename" ) {
  1201.         $bucket = <CLASS>;
  1202.         if ( defined( $bucket ) &&
  1203.            ( $bucket =~ /([^ ]+) MAGNET ([^\r\n]+)/ ) ) {
  1204.             $bucket = $1;
  1205.             $magnet = $2;
  1206.         }
  1207.  
  1208.         $reclassified = 0;
  1209.         if ( defined( $bucket ) && ( $bucket =~ /RECLASSIFIED/ ) ) {
  1210.             $bucket       = <CLASS>;
  1211.             $usedtobe = <CLASS>;
  1212.             $reclassified = 1;
  1213.             $usedtobe =~ s/[\r\n]//g;
  1214.         }
  1215.         close CLASS;
  1216.         $bucket =~ s/[\r\n]//g if defined( $bucket );
  1217.         unlink $filename;
  1218.     } else {
  1219.         return ( undef, $bucket, undef, undef );
  1220.     }
  1221.  
  1222.     $bucket = 'unknown class' if ( !defined( $bucket ) );
  1223.  
  1224.     return ( $reclassified, $bucket, $usedtobe, $magnet );
  1225. }
  1226.  
  1227. #----------------------------------------------------------------------------
  1228. #
  1229. # cleanup_history
  1230. #
  1231. # Removes the popfile*.msg files that are older than a number of days
  1232. # configured as history_days.
  1233. #
  1234. #----------------------------------------------------------------------------
  1235. sub cleanup_history
  1236. {
  1237.     my ( $self ) = @_;
  1238.  
  1239.     my $seconds_per_day = 24 * 60 * 60;
  1240.     my $old = time - $self->config_( 'history_days' ) * $seconds_per_day;
  1241.     my $d = $self->db__()->prepare( "select id from history
  1242.                                          where inserted < $old;" );
  1243.     $d->execute;
  1244.     my @row;
  1245.     my @ids;
  1246.     while ( @row = $d->fetchrow_array ) {
  1247.         push ( @ids, $row[0] );
  1248.     }
  1249.     foreach my $id (@ids) {
  1250.         $self->delete_slot( $id, 1 );
  1251.     }
  1252. }
  1253.  
  1254. # ---------------------------------------------------------------------------
  1255. #
  1256. # copy_file__
  1257. #
  1258. # Utility to copy a file and ensure that the path it is going to
  1259. # exists
  1260. #
  1261. # $from               Where to copy from
  1262. # $to_dir             The directory it will be copied to
  1263. # $to_name            The name of the destination (without the directory)
  1264. #
  1265. # ---------------------------------------------------------------------------
  1266. sub copy_file__
  1267. {
  1268.     my ( $self, $from, $to_dir, $to_name ) = @_;
  1269.  
  1270.     if ( open( FROM, "<$from") ) {
  1271.         if ( open( TO, ">$to_dir\/$to_name") ) {
  1272.             binmode FROM;
  1273.             binmode TO;
  1274.             while (<FROM>) {
  1275.                 print TO $_;
  1276.             }
  1277.             close TO;
  1278.         }
  1279.  
  1280.         close FROM;
  1281.     }
  1282. }
  1283.  
  1284. # ---------------------------------------------------------------------------
  1285. #
  1286. # force_requery__
  1287. #
  1288. # Called when the database has changed to invalidate any queries that are
  1289. # open so that cached data is not returned and the database is requeried
  1290. #
  1291. # ---------------------------------------------------------------------------
  1292. sub force_requery__
  1293. {
  1294.     my ( $self ) = @_;
  1295.     # Force requery since the messages have changed
  1296.  
  1297.     foreach my $id (keys %{$self->{queries__}}) {
  1298.         $self->{queries__}{$id}{fields} = '';
  1299.     }
  1300. }
  1301.  
  1302. # SETTER
  1303.  
  1304. sub classifier
  1305. {
  1306.     my ( $self, $classifier ) = @_;
  1307.  
  1308.     $self->{classifier__} = $classifier;
  1309. }
  1310.  
  1311. 1;
  1312.